{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Majalan.Base.Score
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Monadic score type.
-- 
--------------------------------------------------------------------------------

module Majalan.Base.Score
  ( 

    ScoreEnv
  , Part
  , Score
  , ScoreObj
  , score
  , renderScoreObj


  , eventList
  , eventListPos

  , part
  , part_
  , namedPart
  , namedPart_
  , mute
  , bracket
  , beatPatternAt       -- ? Maybe not so good...
  
  , clickTrack

  )  where


import Majalan.Base.BeatPattern
import Majalan.Base.Context
import Majalan.Base.Event
import Majalan.Base.EventList
import Majalan.Base.Impulse
import Majalan.Base.Internal.Base
import Majalan.Base.Internal.Doc
import Majalan.Base.Internal.IStmt
import Majalan.Base.Internal.Utils
import Majalan.Base.Processor
import Majalan.Base.Timeline

import Text.PrettyPrint.HughesPJ ( Doc ) -- package: pretty


import Control.Applicative
import qualified Data.Map as Map
import Data.Monoid

--------------------------------------------------------------------------------
-- (User) Score


--
-- Don\'t support concatenation, instead consider Score a
-- singleton object. Construct a score by adding parts (tracks), 
-- rather than composing scores.
-- 


data PartId = GenId Int
            | Named String
  deriving (Eq,Ord,Show)


partName :: PartId -> String
partName (GenId i) = "Part " ++ show i
partName (Named s) = s

type W = H CsPart


type ScoreEnv = Timeline

-- Cannot store impulse maps in state as they have different 
-- types - must be bound within do-notation.
--
data St = St { st_part_count    :: !Int
             , st_part_tspans   :: Map.Map PartId TimeSpan
             }

state_zero :: St
state_zero = St { st_part_count    = 1
                , st_part_tspans   = Map.empty
                }



data Ans a = Ans !St !W a

instance Functor Ans  where
  fmap f (Ans s w a) = Ans s w (f a)
  

--
-- Score has an immutable (no local operation) 
-- context with timeline.
--
-- Other objects should have a context with tempo/ bpm.
--
-- Score can then use timeline for a snapping grid - symbolic
-- placement of parts rather than absolute placement.
--
-- Score should just have uctx, not Ctx uctx.
-- TimeSig and tempo to be queried from timeline at point of use.
--
newtype Score uctx a = Score { 
    getScore :: ScoreEnv -> uctx -> St -> Ans a }

instance Functor (Score uctx) where
  fmap f ma = Score $ \q r s -> fmap f $ getScore ma q r s
                
instance Applicative (Score uctx) where
  pure a    = Score $ \_ _ s -> Ans s emptyH a
  mf <*> ma = Score $ \q r s -> 
                let Ans s1 w1 f = getScore mf q r s
                    Ans s2 w2 a = getScore ma q r s1
                in Ans s2 (w1 `appendH` w2) (f a)


instance Monad (Score uctx) where
  return    = pure
  ma >>= k  = Score $ \q r s -> 
                let Ans s1 w1 a = getScore ma q r s 
                    Ans s2 w2 b = getScore (k a) q r s1
                in Ans s2 (w1 `appendH` w2) b

type instance UserCtx (Score uctx) = uctx



-- Design Note - the score function groups together information 
-- that is too disparate (ColumnSpecs - ScoreEnv & uctx).
-- ColumnSpecs are typographical, ScoreEnv and uctx are musical.


data ScoreObj = forall uctx a. ScoreObj
    { sc_env    :: ScoreEnv
    , sc_uctx   :: uctx
    , sc_score  :: Score uctx a
    }                                

score :: ScoreEnv -> uctx -> Score uctx a -> ScoreObj
score senv uctx ma = ScoreObj { sc_env    = senv
                              , sc_uctx   = uctx
                              , sc_score  = ma
                              } 

renderScoreObj :: ColumnSpecs -> ScoreObj -> Doc
renderScoreObj specs (ScoreObj senv uctx ma) = 
    let Ans _ sco _ = getScore ma senv uctx state_zero
        parts       = toListH sco
        doc         = render specs parts
    in doc


nextPartId :: Score uctx PartId
nextPartId = Score $ \_ _ s -> 
    let i = st_part_count s 
    in Ans (s { st_part_count = i+1 }) emptyH (GenId i)



addTimeSpan :: PartId -> TimeSpan -> Score uctx ()
addTimeSpan k v = Score $ \_ _ s -> 
    let m = Map.insert k v $ st_part_tspans s
    in Ans (s { st_part_tspans = m}) emptyH ()
    

scoreTell :: PartId -> [IStmt] -> Score uctx ()
scoreTell pid body = Score $ \_ _ s -> 
    Ans s (wrapH $ CsPart (partName pid) body) ()



 
-- | Tell-like function 
--
writePart :: (PartId -> PartId) -> Part uctx a 
          -> Score uctx PartId
writePart namef ma = 
    mfun                            >>= \(tspan, hstmts, _) -> 
    fmap namef nextPartId           >>= \key ->
    addTimeSpan key tspan           >>
    scoreTell key (toListH hstmts)  >>
    return key
  where
    mfun  = Score $ \q r s -> 
              let ema = getPart ma q
                  a1  = runEventList (initialCtx r) 0 ema 
              in Ans s emptyH a1


--------------------------------------------------------------------------------
-- Parts

-- part API is wrong - should allow multiple event lists in a part 
-- associated with their onset.

newtype Part uctx a = Part { 
    getPart :: ScoreEnv -> EventList uctx a }


instance Functor (Part uctx) where
  fmap f ma = Part $ \q -> fmap f $ getPart ma q

instance Applicative (Part uctx) where
  pure a    = Part $ \_ -> pure a
  mf <*> ma = Part $ \q -> getPart mf q <*> getPart ma q
 
instance Monad (Part uctx) where
  return    = pure
  ma >>= k  = Part $ \q -> 
                getPart ma q >>= \a -> getPart (k a) q

instance Monoid a => Monoid (Part uctx a) where
  mempty          = Part $ \_ -> mempty
  ma `mappend` mb = Part $ \q -> 
                      getPart ma q `mappend` getPart mb q


type instance UserCtx (Part uctx) = uctx


instance ContextM (Part uctx) where
  askCtx        = Part $ \_ -> askCtx 
  localize f ma = Part $ \q -> localize f (getPart ma q)


metricalInfoAtAbs :: Seconds -> Part uctx (TimeSig,BPM)
metricalInfoAtAbs dt = Part $ \q -> pure $ getMetricalInfoAbs dt q

metricalInfoAtPos :: ScorePos -> Part uctx (TimeSig,BPM)
metricalInfoAtPos sp = Part $ \q -> pure $ getMetricalInfoPos sp q



primEventListAbs :: Seconds -> EventList uctx a -> Part uctx a
primEventListAbs dt ma = Part $ \q -> 
    getPart (metricalInfoAtAbs dt) q >>= \(ts,bpm) -> 
    localize (set_metered ts bpm) $ displace dt ma


primEventListPos :: ScorePos -> EventList uctx a -> Part uctx a
primEventListPos sp ma = Part $ \q -> 
    let dt = getPosition sp q 
    in getPart (metricalInfoAtPos sp) q >>= \(ts,bpm) -> 
       localize (set_metered ts bpm) $ displace dt ma


eventList :: Seconds -> EventList uctx a -> Part uctx a
eventList = primEventListAbs

eventListPos :: ScorePos -> EventList uctx a -> Part uctx a
eventListPos = primEventListPos



part :: Part uctx a -> Score uctx PartId
part = writePart id


part_ :: Part uctx a -> Score uctx ()
part_ ma = const () <$> part ma


namedPart :: String -> Part uctx a -> Score uctx PartId
namedPart s = writePart (const $ Named s)

namedPart_ :: String -> Part uctx a -> Score uctx ()
namedPart_ s ma = const () <$> writePart (const $ Named s) ma



-- | Censor like function
--
mute :: Score uctx a -> Score uctx a
mute ma = Score $ \q r s -> 
    let (Ans s1 _ a) = getScore ma q r s in Ans s1 emptyH a



-- Note - compositionality of bracket is poor and gives us a 
-- poor API...
--
bracket :: PartId -> Processor -> Score uctx ()
bracket pid proc  = Score $ \_ _ s -> 
    case Map.lookup pid (st_part_tspans s) of
      Nothing -> Ans s emptyH ()        -- Add error handling?
      Just tspan -> let (_,istmt)   = applyProcessor proc tspan 
                        anon_part   = CsPart "" [istmt]
                    in Ans s (wrapH anon_part) ()


beatPatternAt :: ScorePos -> BeatPattern a -> Part uctx (ImpulseMap a)
beatPatternAt posn patn = 
    metricalInfoAtPos posn >>= \(ts,bpm) ->
    return $ beatPattern ts bpm patn

--------------------------------------------------------------------------------


getTimeline :: Score uctx Timeline
getTimeline = Score $ \q _ s -> Ans s emptyH q


-- Should this be a FwEvent - as it does not get a duration 
-- component?
--
-- Also chain too heavyweight for this as traversal closer to 
-- mapping than stepping.
--
clickTrack :: Int -> EventFw uctx a -> Score uctx PartId
clickTrack bmax mf = getTimeline >>= \tl -> 
    let imap = timelineToImpulses bmax tl 
    in part $ eventList 0 $ impulsesFw imap (\_ -> mf)
